home *** CD-ROM | disk | FTP | other *** search
/ Software of the Month Club 1996 November / Software of the Month Club 1996 November.iso / pc / dos / edu / activem / frank.bas next >
Encoding:
BASIC Source File  |  1994-10-05  |  15.7 KB  |  444 lines
  1. ' Frankenstein word game programme originating as PC-SIG no 18
  2. ' Rewrite by John Calder,Box 41-076, Auckland 3, NZ, ph 8282612, Nov 1992
  3. ' adding colours and CLUEs
  4. ' Further rewrite using PowerBASIC April 1993 to Oct 1994
  5. ' You should be able to play with it using QBASIC.
  6. '
  7. ' NOTE that in rigorous computer programming terms this is now a mongrel
  8. ' being my improvements written in the modern structured style
  9. ' grafted on to the earlier original code.
  10. '
  11. ' diary 18/9/94 .. * LCASE$ and REMOVE$ blanks on game words for some kind
  12. '                    of OK operation when kids write their own
  13. '
  14. ' update 20/3/94   * make programme a little easier to read for exhibition.
  15. '                  * add auto shut off after 120 sec inactivity to save
  16. '                    Stan's generously loaned screen from fade-out!
  17. '
  18. ' update 8/9/93... * change "play again Y/N" question to "press ENTER..."
  19. '                    as words with "n" were causing premature stop
  20. '                  * define F3 key as EXIT for compatiblity with GRAPHs
  21. '                    and simpler progs using "input" .  ESC still operates
  22. '
  23. ' update 2/9/93... * change use of timer with output displays
  24. '                  * ADD markcard with new variables MARK and NQU
  25. '
  26. '
  27.  
  28. 15  REM
  29. 20  REM ************************  Documentation ******************************
  30. 22  REM   NW       = number of words read by SUB 1000 on prog startup
  31. 24  REM   CU$      = control of display in answer space
  32. 27  REM   A        = control of display of the alphabet and letters used
  33. 30  REM   H$( )    = word chosen from word list by random selection
  34. 31  REM   L        = length of H$
  35. 32  REM   CLUE$( ) = clue to H$
  36. 34  REM              NOTE word list data is in form H$ CLUE$ H$ CLUE$ ...
  37. 36  REM   W$( )    = letters of that word, usual subscript is X
  38. 37  REM   W( )     = associated flag, starts at 0, becomes 1 on correct guess
  39. '***      MARK     = number correct
  40. '***      NQU      = number attempted
  41. '***
  42. 40  REM   SUB 1000   Sort through words and count them to get NW
  43. 41  REM
  44. 42  REM
  45. 44  REM   SUB 3020   monster appearing bit by bit with wrong guesses
  46. 45  REM              up to line 3720
  47. 47  REM   SUB 3810   Monster animates arm flap
  48. 48  REM
  49. 49  REM   SUB 4000   correct answer reaction and offer signoff routine
  50. 50  REM
  51. 51  REM
  52. 52  REM   SUB 59950  TIMEOUT routine for timing pauses
  53. 54  REM   SUB 59990  direct input routine using INKEY$ allows analysis
  54. '                    of each character
  55.  
  56. 55  REM Programme setup
  57. 60      WIDTH 80 : CLS : DEFINT A-S,U-Z : CU$="     "
  58.         key 2,"░"      '*** chr$(176) see lines 180+2 and 230 for usage
  59.         key 3,chr$(27) '*** F3 as exit
  60.         key 7,chr$(27) '*** F7 as exit like WordPerfect which our kids use
  61.         mark = 0 : nqu = 0
  62.  
  63. 74  DIM H$(325) , H(150), A$(150), A(150), W$(150), W(150), U$(50)
  64.     DIM U(50), CLUE$(325)
  65. 75  RANDOMIZE TIMER
  66. '***   REWRITE APRIL 1993 takes data from separate sequential file
  67.        open "i",#1, "frank.txt"
  68.        nw = 0
  69.        do until eof(1)
  70.       nw = nw + 1
  71.       line input #1, h$(nw)
  72.       line input #1, clue$(nw)
  73.       h$(nw) = LCASE$(h$(nw))          '***** 18/9/94 emergency rewrite
  74.       h$(nw) = REMOVE$( h$(nw) , " ")  'for better write-your-own word
  75.        loop
  76.        close #1
  77.  
  78.  
  79.  
  80. '*** gosub 3000 for setup of ASCII graphics of Frankenstein's lab
  81. 76     z = 0  : GOSUB 3000
  82. 78     FOR X=13 TO 15: LOCATE X,1: PRINT STRING$(80,"█");: NEXT X
  83. 80     FOR X=1 TO NW:IF H(X)=0 THEN 100 ELSE NEXT X
  84. 90     FOR X=1 TO NW:H(X)=0:NEXT X:H=INT(RND*NW+1):GOTO 110
  85. 100    FOR T=1 TO 5:H=INT(RND*NW+1):IF H(H)=0 THEN 110 ELSE NEXT T:H=X
  86. 110    H$=H$(H): H(H)=1
  87. 120    L=LEN(H$)
  88. 130    FOR X=1 TO L: W$(X)=MID$(H$,X,1): W(X)=0: NEXT X
  89. 140   LOCATE 14,39-cint(L/2): PRINT STRING$(L+2," ");
  90. 145   LOCATE 14,40-cint(L/2): COLOR 10: PRINT STRING$(L,"-");: COLOR 7
  91. 148     REM
  92. 149   REM ******  set up the alphabet line  NOTE my change to lower case ***
  93. 150     FOR X=97 TO 122: A$(X)=CHR$(X): NEXT X
  94. 160   LOCATE 16,1: PRINT SPACE$(80);: LOCATE 16,1: PRINT"What's your letter?";
  95.  
  96. 165   COLOR 12
  97. 170   LOCATE 18,5:PRINT STRING$(70,"▄");
  98. 175   COLOR 7
  99. 180   LOCATE 20,14: FOR X=97 TO 122: PRINT A$(X)" ";: NEXT X
  100.       locate 24,1
  101.       color 15,4 : print"F2"; : color 11: print"=guess whole word    ";
  102.       color 15   : print" F3"; : color 11: print"=exit    ";
  103.       color 15   : print"ENTER";
  104.       color 11   : print"=zap past messages                    ";
  105. 190   CU=22
  106.  
  107. 200   COLOR 10,0                                  'change 14/9/93 overcomes
  108.       LOCATE 16,42 : PRINT "CLUE:  " + CLUE$(H)   'prob of rubout of long
  109.       color 7                                     'clues printed on line 17
  110.       IKEY$="": LOCATE 16,CU : PRINT CU$;
  111.       locate 16,cu,1
  112.       if flag = 1 then         'this little lot is the new routine 2/9/93
  113.           ikey$ = ikal$        'to allow quick players to zap past the timeout.
  114.           flag = 0             'IKAL$ is the Input Key ALternative inkey$ by
  115.       else                     'zappers in timeout routine 59950 gosub-ed
  116.           GOSUB 59990          'from line 370 which is end of this main loop
  117.       end if
  118.       beep
  119.  
  120. 230   IF IKEY$="░" THEN 2000
  121. 240   A = ASC(IKEY$) : IF A<91 THEN A=A+32 : IKEY$=CHR$(A)
  122. 250   IF INSTR("abcdefghijklmnopqrstuvwxyz",IKEY$)=0 THEN 200
  123. 260   LOCATE 16,CU : PRINT IKEY$;
  124. 270   IF A$(A)=" " THEN
  125.          LOCATE 17,1,0 : PRINT"You've already used "IKEY$"!";
  126.          TIMEOUT=2.8 : flag=1 : GOSUB 59950
  127.          LOCATE 17,1 : PRINT SPACE$(50);:GOTO 200
  128.       end if
  129. 280   S=0:NC=0:FOR X=1 TO L
  130. 290   IF W$(X)=IKEY$ THEN W(X)=1:S=S+1
  131. 300   IF W(X)=1 THEN NC=NC+1
  132. 310   NEXT X
  133. 320   IF NC=L THEN 340
  134. 330      IF S<>0 THEN 340
  135. 332      IF Z>=7 THEN 3800
  136. 334      LOCATE 17,1,0 :PRINT"The monster gets ";: GOSUB 3000
  137.          TIMEOUT=2: flag = 1 : GOSUB 59950: LOCATE 17,1: PRINT SPACE$(50);
  138.          A$(A)=" ": GOTO 180
  139. 340   LOCATE 14,40-L/2,0 : COLOR 10
  140. 350   FOR X=1 TO L: IF W(X)=1 THEN PRINT W$(X); ELSE PRINT"-";
  141. 360   NEXT X: COLOR 7: A$(A)=" ": IF NC=L THEN 4000
  142. 370   TIMEOUT = 0.9     ' **** note lots of experimenting with this time!
  143.       flag = 1  : GOSUB 59950  :  GOTO 180
  144.  
  145. '***   Routine for guessing whole word
  146. 2000   LOCATE 16,1: PRINT SPACE$(46)
  147.        LOCATE 16,1: PRINT"What's your guess for the word?   ";
  148.        LOCATE 16,39-cint(L/2) : call MonoInput(W$,itype)
  149.        IF itype = 27 THEN 59992   'branch into exit part of inkey$ routine
  150.  
  151.        IF len(w$) = len(h$) THEN
  152.           '*** Case conversion on word estimate
  153.           W5$ = ""
  154.           FOR I5 = 1 TO LEN(H$)
  155.             A5 = ASC(MID$(W$,I5,1))
  156.             IF A5<91 AND A5>64 THEN A5=A5+32
  157.             W5$ = W5$ + CHR$(A5)
  158.           NEXT I5
  159.           IF W5$=H$ THEN 4000  '*** where student guesses word correctly
  160.           LOCATE 16,1: PRINT SPACE$(33);
  161.           LOCATE 16,1: PRINT"No, there goes ";
  162.           GOSUB 3000 : beep
  163.           TIMEOUT=5 : flag = 1 : GOSUB 59950: GOTO 160
  164.        else
  165.           locate 16,1 : print space$(33)
  166.           locate 16,1 : print "Wrong length, here's ";
  167.           GOSUB 3000 : beep
  168.           TIMEOUT=5 : flag = 1 : GOSUB 59950: GOTO 160
  169.        END IF
  170.  
  171. 'Graphic display section
  172. 3000 Z=Z+1:ON Z GOTO 3100, 3200,3300,3400,3500,3600,3700,3800
  173. 3010 STOP
  174. 3100 LET nqu = nqu + 1 : COLOR 12
  175.      LOCATE 1,1:PRINT STRING$(80,"▀");:LOCATE 12,1:PRINT STRING$(80,"▄");
  176.      FOR X=1 TO 12:LOCATE X,1:PRINT"█";:LOCATE X,80:PRINT"█";:NEXT X
  177.      LOCATE 2,28:COLOR 15:PRINT"F R A N K E N S T E I N";:COLOR 7
  178.      FOR X=6 TO 12
  179.          LOCATE X,10:PRINT STRING$(8,"█");
  180.          LOCATE X,62:PRINT STRING$(8,"█");
  181.      NEXT X
  182.      LOCATE 5,13:PRINT"██";:LOCATE 5,65:PRINT"██";
  183. 3120 RETURN
  184. 3200 PRINT"his body!  ";
  185. 3210 COLOR 13
  186.      LOCATE 6,37:PRINT STRING$(7,"█")
  187.      locate 7,38:print STRING$(5,"█")
  188.      locate 8,39:print STRING$(3,"█")
  189.      locate 9,40: print "█";
  190.      COLOR 7
  191. 3220 RETURN
  192. 3300 PRINT"his arm!  ";
  193. 3310 COLOR 13
  194.      LOCATE 6,35: PRINT"▄▄"
  195.      locate 7,35: print"█"
  196.      locate 8,35: print"█";
  197.      COLOR 7
  198. 3320 RETURN
  199. 3400 PRINT"his other arm!";
  200.      color 13
  201.      LOCATE 6,44: PRINT"▄▄"
  202.      locate 7,44: print" █"
  203.      locate 8,44: print" █";
  204.      COLOR 7
  205. 3420 RETURN
  206. 3500 PRINT"his leg!  ";
  207. 3510 COLOR 13
  208.      LOCATE  9,38 : PRINT" ▄"
  209.      locate 10,38 : print" █"
  210.      locate 11,38 : print"▄█";
  211.      COLOR 7
  212. 3520 RETURN
  213. 3600 PRINT"his other leg!";
  214. 3610 COLOR 13
  215.      LOCATE  9,41: PRINT"▄"
  216.      locate 10,41: print"█"
  217.      locate 11,41: print"█▄";
  218.      COLOR 7
  219. 3620 RETURN
  220. 3700 PRINT"his head!  ";
  221. 3710 COLOR 13
  222.      LOCATE  3,39: PRINT"███"
  223.      locate  4,39: print"▌█▐"
  224.      locate  5,39: print"█▀█";
  225.      COLOR 7
  226. 3720 RETURN
  227. 3800 LOCATE 16,1:PRINT"     The word was   "; : color 14 : print H$ ;
  228.      TIMEOUT=2 : GOSUB 59950
  229.      color 15  : PRINT"    The MONSTER lives!!!                ";
  230.      color  7  : TIMEOUT=2: GOSUB 59950
  231. '*** animation sequence for waving arms
  232. 3810 FOR X=1 TO 10
  233. '*** draw in arms up
  234.      COLOR 13
  235.      locate 4,35: print"█" ;
  236.      locate 5,35: print"█" ;
  237.      locate 6,35: print"▀▀";
  238.      locate 4,44: print" █";
  239.      locate 5,44: print" █";
  240.      locate 6,44: print"▀▀";
  241. '*** blank out arms down
  242.      locate 7,35: print" "
  243.      locate 8,35: print" ";
  244.      locate 7,44: print"  "
  245.      locate 8,44: print"  ";
  246. 3860 delay 0.1
  247. '*** draw arms down again
  248.      LOCATE 6,35: PRINT"▄▄"
  249.      locate 7,35: print"█"
  250.      locate 8,35: print"█";
  251.      LOCATE 6,44: PRINT"▄▄"
  252.      locate 7,44: print" █"
  253.      locate 8,44: print" █";
  254. '*** blank out arms up
  255.      locate 5,35: print" ";
  256.      locate 4,35: print" ";
  257.      locate 5,44: print"  ";
  258.      locate 4,44: print"  ";
  259.      delay 0.1
  260. 3905 NEXT X
  261.      color 7
  262. 3910 LOCATE 17,1 : PRINT SPACE$(80)
  263.      LOCATE 17,1 : PRINT"press ENTER for next word";
  264. 3920 GOTO 4010
  265.  
  266. '*** Correct answer routine
  267. 4000 mark = mark + 1
  268.      do : loop until inkey$ = ""        '*** empty keyboard buffer
  269.      LOCATE 16,1 : color 15 : PRINT"Yes!! press ENTER for next word"
  270. '*** I've added line 4005 here to give better feedback to a correct guess and
  271. '*** also to keep the word on screen for learning reinforcement.
  272. 4005 LOCATE 14,40-cint(L/2) : COLOR 10: PRINT H$; : COLOR 7
  273. 4010 GOSUB 59990
  274. 4020 BEEP
  275.      if ikey$ = chr$(27) then call MarkCard else CLS: GOTO 76
  276.  
  277.  
  278. 59940 REM *** SUB for timing pauses where TIMEOUT is length of pause in seconds
  279. 59950 tx = timer
  280.       do until timer - tx >= timeout
  281.       if flag = 1 then
  282.          ikal$ = inkey$
  283.          if ikal$ <> "" then return
  284.       end if
  285.       loop
  286.       flag = 0
  287.       return
  288.  
  289.  
  290. 59990 REM *** SUB for input with INKEY$ which allows analysis of each character
  291.       REM         as it is typed
  292.       t1 = TIMER
  293.       DO
  294.       ikey$=INKEY$
  295.       IF TIMER - t1 > 140 THEN END
  296.       LOOP UNTIL ikey$ > ""
  297.       IF IKEY$=CHR$(27) THEN
  298. 59992     color 11
  299.           locate 21,7 : print"╔════════════════════════════════════════════╗"
  300.           locate 22,7 : print"║                                            ║"
  301.           locate 23,7 : print"╚════════════════════════════════════════════╝"
  302.           LOCATE 22, 9: color 12 :print "The word was   ";
  303.           COLOR 14 : PRINT H$(H);: COLOR 12: PRINT "  !"
  304.           TIMEOUT=5: flag = 1 : GOSUB 59950: call MarkCard
  305.       end if
  306. 59995 RETURN
  307.  
  308.  
  309. '***************************************************************************
  310. SUB MarkCard
  311. SHARED mark, nqu
  312. cls
  313. color 15,2
  314. locate  6,7 : print"╔════════════════════════════════════════════╗"
  315. locate  7,7 : print"║    Progress Report                         ║"
  316. locate  8,7 : print"║                                            ║"
  317. locate  9,7 : print"║    You got        words out of             ║"
  318. locate 10,7 : print"║                                            ║"
  319. locate 11,7 : print"║    That is        per cent                 ║"
  320. locate 12,7 : print"║                                            ║"
  321. locate 13,7 : print"║                                            ║"
  322. locate 14,7 : print"║    Press ENTER key to exit                 ║"
  323. locate 15,7 : print"║                                            ║"
  324. locate 16,7 : print"╚════════════════════════════════════════════╝"
  325. locate  9,21 : print mark
  326. locate  9,41 : print nqu
  327. locate 11,20 : print cint(mark/nqu * 100)
  328. locate 18,1
  329.     t1 = TIMER
  330.     do
  331.     ikey$ = inkey$
  332.     IF TIMER - t1 > 30 THEN END
  333.     loop until ikey$ <> ""
  334. color 7,0 : cls
  335. END
  336. END SUB
  337.  
  338. '***************************************************************************
  339. '*** subroutine with INKEY$ substituting for INPUT
  340. '*** Returns  A which is input string   and  IA  which is final keystroke
  341. '*** causing exit from sub  ..IA = 13 for normal 'ENTER' or 27 for 'ESC'
  342. '*** or for FRANK 8/9/93 IA = 238 for F3
  343.  
  344. defstr a - e : defint f - n
  345.  
  346. SUB MonoInput(a, ia)
  347.     DIM DINPUT(50)
  348.     COLOR 14,0
  349.     KSTART = POS : KCOL = KSTART + 1 : KLINE = CSRLIN : a =""
  350.     insflag = 6   '*** 6 for INSERT OFF ; 3 for INSERT ON
  351.     lenfield = 2
  352.  
  353. start:
  354. if kcol > 80 then kcol = 1 : kline = kline + 1
  355. LOCATE kline, kcol, 1, insflag, 7
  356.  
  357. '** main input routine with closedown after 120 sec if no input    
  358.     t1 = TIMER
  359.     DO   
  360.     ak = INKEY$ 
  361.     IF TIMER - t1 > 120 THEN END
  362.     LOOP UNTIL ak > ""
  363.  
  364.     IA = ASC(AK)
  365.     IF IA = 27  THEN color 7,0 : EXIT SUB     '*** Esc F3 F7 keys
  366.     IF IA = 13 THEN AssembleA    '*** input completed on ENTER
  367.  
  368. '************** start of ARROW KEYS trap and control section *************
  369. IF IA = 0  THEN
  370.    IF ASC(RIGHT$(AK,1)) = 77 THEN                        '*** right arrow
  371.        KCOL = KCOL + 1
  372.    ELSEIF ASC(RIGHT$(AK,1)) = 75 AND KCOL > KSTART THEN  '*** Left Arrow
  373.        KCOL = KCOL - 1
  374.        GOTO start
  375.    ELSEIF ASC(RIGHT$(AK,1)) = 71 THEN                   '*** HOME arrow
  376.        KCOL = KSTART + 1
  377.        GOTO start
  378.    ELSEIF ASC(RIGHT$(AK,1)) = 79 THEN                   '*** END arrow
  379.        KCOL = KSTART + LENFIELD
  380.        GOTO start
  381.    ELSEIF ASC(RIGHT$(AK,1)) = 83 THEN                   '*** Delete key
  382.        FOR J = KCOL - KSTART  TO  LENFIELD + 1
  383.        DINPUT(J) = DINPUT(J+1) : PRINT DINPUT(J) ;
  384.        NEXT J
  385.        PRINT " ";
  386.        GOTO start
  387.    ELSEIF ASC(RIGHT$(AK,1)) = 82 THEN   '*** Insert key procedure & flag
  388.        IF INSFLAG = 3 THEN INSFLAG = 6 ELSE INSFLAG = 3
  389.        GOTO start
  390.    ELSE
  391.        GOTO start
  392.    END IF
  393.  
  394. END IF
  395. '**************** END of arrow keys control section ************************
  396.  
  397.        IF IA = 8  THEN              '*** Backspace key
  398.          IF KCOL = KSTART + 1 THEN start
  399.          KCOL = KCOL - 1
  400.          LOCATE KLINE, KCOL,1,5,7
  401.          FOR J = KCOL - KSTART  TO  LENFIELD + 1
  402.          DINPUT(J) = DINPUT(J+1) : PRINT DINPUT(J) ;
  403.          NEXT J
  404.          PRINT " ";
  405.          GOTO start
  406.          END IF
  407.        IF IA = 237 THEN   '*** F7 key for delete to end of input
  408.          FOR J = KCOL-KSTART TO LENFIELD
  409.               DINPUT (J) = ""
  410.               NEXT J
  411.          FOR K = KCOL TO LENFIELD + KSTART
  412.               LOCATE KLINE,K
  413.               PRINT " ";
  414.               NEXT K
  415.          GOTO start
  416.          END IF
  417.        IF IA > 230 THEN EXIT SUB    '*** F-keys
  418.  
  419. '****  Structured IF statement here is the main input construct
  420.        IF 31 < IA  AND  IA <= 230  THEN
  421.           LOCATE KLINE, KCOL : COLOR 14,0
  422.           PRINT CHR$(IA);
  423.           lenfield = lenfield + 1
  424.           IF INSFLAG = 3 THEN             '*** insert procedure
  425.              FOR J = LENFIELD  TO  KCOL-KSTART+1  STEP  -1
  426.              DINPUT(J) = DINPUT(J-1)
  427.              LOCATE KLINE, J+KSTART : PRINT DINPUT(J) ;
  428.              NEXT J
  429.        END IF
  430.        DINPUT( KCOL-KSTART ) = CHR$(IA)
  431.        KCOL = KCOL + 1
  432.        END IF
  433.        GOTO start
  434.  
  435. AssembleA:
  436.        FOR i = 1 TO lenfield
  437.        a = a + dinput(i)
  438.        NEXT i
  439.        color 7,0
  440. END SUB
  441.  
  442. '***************** end of FRANK programme **********************************
  443.  
  444.